Night Owl 6/Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso/037a/ccunzip.zip/UNZ4.PAS

Pascal/Delphi Source File | 1990-04-05 | 34KB | 1,263 lines

(*
 * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
 *
 * This is a component of the ProDoor System.
 * Do not distribute modified versions without my permission.
 * Do not remove or alter this notice or any other copyright notice.
 * If you use this in your own program you must distribute source code.
 * Do not use any of this in a commercial product.
 *
 *)

(*
 * UnZip - A simple zipfile extract utility
 *
 *)

{$I+}                             {I/O checking}
{$N-}                             {Numeric coprocessor}
{$V-}                             {Relaxes string typing}
{$B-}                             {Boolean complete evaluation}
{$S-}                             {Stack checking}
{$R-}                             {Range checking}
{$D+}                             {Global debug information}
{$L+}                             {Local debug information}

{$M 5000,0,0}                     {minstack,minheap,maxheap}

program UnZip;

uses
  Dos, Mdosio, crc;

const
  version        = 'UnZ:  Zipfile Extract v2.0 (PAS) of 09-09-89;  (C) 1989 S.H.Smith';



(*
 * Data declarations for the archive text-view functions.
 *
 *)

  (* ----------------------------------------------------------- *)
(*
 * ZIPfile layout declarations
 *
 *)

type
  signature_type = LongInt;

const
  local_file_header_signature = $04034b50;

type
  local_file_header = record
                        version_needed_to_extract : Word;
                        general_purpose_bit_flag : Word;
                        compression_method : Word;
                        last_mod_file_time : Word;
                        last_mod_file_date : Word;
                        crc32          : LongInt;
                        compressed_size : LongInt;
                        uncompressed_size : LongInt;
                        filename_length : Word;
                        extra_field_length : Word;
                      end;

const
  central_file_header_signature = $02014b50;

type
  central_directory_file_header = record
                                    version_made_by : Word;
                                    version_needed_to_extract : Word;
                                    general_purpose_bit_flag : Word;
                                    compression_method : Word;
                                    last_mod_file_time : Word;
                                    last_mod_file_date : Word;
                                    crc32          : LongInt;
                                    compressed_size : LongInt;
                                    uncompressed_size : LongInt;
                                    filename_length : Word;
                                    extra_field_length : Word;
                                    file_comment_length : Word;
                                    disk_number_start : Word;
                                    internal_file_attributes : Word;
                                    external_file_attributes : LongInt;
                                    relative_offset_local_header : LongInt;
                                  end;

const
  end_central_dir_signature = $06054b50;

type
  end_central_dir_record = record
                             number_this_disk : Word;
                             number_disk_with_start_central_directory : Word;
                             total_entries_central_dir_on_this_disk : Word;
                             total_entries_central_dir : Word;
                             size_central_directory : LongInt;
                             offset_start_central_directory : LongInt;
                             zipfile_comment_length : Word;
                           end;



  (* ----------------------------------------------------------- *)
(*
 * input file variables
 *
 *)

const
  uinbufsize     = 512;           {input buffer size}
var
  zipeof         : Boolean;
  Crc32Val       : LongInt;
  InCrc          : LongInt;
  csize          : LongInt;
  cusize         : LongInt;
  cmethod        : Integer;
  cflags         : Word;

  ctime          : Word;
  cdate          : Word;
  inbuf          : array[1..uinbufsize] of Byte;
  inpos          : Integer;
  incnt          : Integer;
  pc             : Byte;
  pcbits         : Byte;
  pcbitv         : Byte;
  zipfd          : dos_handle;
  zipfn          : dos_filename;



  (* ----------------------------------------------------------- *)
(*
 * output stream variables
 *
 *)

var
  outbuf         : array[0..8192] of Byte; {8192 or more for rle look-back}
  outpos         : LongInt;       {absolute position in outfile}
  outcnt         : Integer;
  outfd          : dos_handle;
  filename       : String;
  extra          : String;



  (* ----------------------------------------------------------- *)

type
  Sarray         = array[0..255] of String[64];

var
  factor         : Integer;
  followers      : Sarray;
  ExState        : Integer;
  C              : Integer;
  V              : Integer;
  Len            : Integer;

const
  hsize          = 8192;

type
  hsize_array_integer = array[0..hsize] of Integer;
  hsize_array_byte = array[0..hsize] of Byte;

var
  prefix_of      : hsize_array_integer;
  suffix_of      : hsize_array_byte;
  stack          : hsize_array_byte;
  stackp         : Integer;

(*
 * Zipfile input/output handlers
 *
 *)


  (* ------------------------------------------------------------- *)
  procedure skip_csize;
  begin
    dos_lseek(zipfd, csize, seek_cur);
    zipeof := True;
    csize := 0;
    incnt := 0;
  end;


  (* ------------------------------------------------------------- *)
  procedure ReadByte(var x : Byte);
  begin
    if inpos > incnt then
      begin
        if csize = 0 then
          begin
            zipeof := True;
            Exit;
          end;

        inpos := SizeOf(inbuf);
        if inpos > csize then
          inpos := csize;
        incnt := dos_read(zipfd, inbuf, inpos);

        inpos := 1;
        Dec(csize, incnt);
      end;

    x := inbuf[inpos];
    Inc(inpos);
  end;


(*
 * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
 *
 * This is a component of the ProDoor System.
 * Do not distribute modified versions without my permission.
 * Do not remove or alter this notice or any other copyright notice.
 * If you use this in your own program you must distribute source code.
 * Do not use any of this in a commercial product.
 *
 *)

(******************************************************
 *
 * Procedure:  itohs
 *
 * Purpose:    converts an integer into a string of hex digits
 *
 * Example:    s := itohs(i);
 *
 *)

  function itohs(i : LongInt) : String; {integer to hex conversion}
  var
    h              : String;

    procedure digit(ix : Integer; ii : LongInt);
    const
     hexdigit:array[0..15] of char = ('0','1','2','3','4','5','6','7',
                                      '8','9','A','B','C','D','E','F');
    begin
      ii := ii and 15;
      h[ix] := hexdigit[ii];
    end;

  begin
    h[0] := Chr(8);
    digit(1, i shr 28);
    digit(2, i shr 24);
    digit(3, i shr 20);
    digit(4, i shr 16);
    digit(5, i shr 12);
    digit(6, i shr 8);
    digit(7, i shr 4);
    digit(8, i);
    itohs := h;
  end;


  (* ------------------------------------------------------------- *)
  procedure ReadBits(bits : Integer; var result : Integer);
    {read the specified number of bits}
  var
    x, t, s, mask  : Integer;
  begin
    if (bits < pcbits)
    then begin
      mask := (1 shl bits)-1;
      x := pc and mask;
      pc := pc shr bits;
      Dec(pcbits, bits);
    end
    else if (bits = pcbits)
    then begin
      x := pc;
      pcbits := 0;
      pc := 0;
    end
    else begin
      x := pc;
      Dec(bits, pcbits);
      s := pcbits;
      while (bits > 0) do
        begin
          ReadByte(pc);
          if bits > 8 then t := 8 else t := bits;
          mask := (1 shl t)-1;
          x := x or ((pc and mask) shl s);
          pcbits := 8-t;
          Inc(s, 8);
          Dec(bits, t);
          pc := pc shr t;
        end;
    end;
    result := x;
  end;


  (* ---------------------------------------------------------- *)
  procedure get_string(ln : Word; var s : String);
  var
    n              : Word;
  begin
    if ln > 255 then
      ln := 255;
    n := dos_read(zipfd, s[1], ln);
    s[0] := Chr(ln);
  end;


  (* ------------------------------------------------------------- *)
  procedure OutByte(C : Integer);
    (* output each character from archive to screen *)
  begin
    outbuf[outcnt {outpos mod sizeof(outbuf)} ] := C;
    Inc(outpos);
    Inc(outcnt);

    if outcnt = SizeOf(outbuf) then
      begin
        Crc32Val := UpdateCRC32(Crc32Val,outbuf,outcnt);
        dos_write(outfd, outbuf, outcnt);
        outcnt := 0;
        Write('.');
      end;
  end;


(*
 * expand 'reduced' members of a zipfile
 *
 *)

(*
 * The Reducing algorithm is actually a combination of two
 * distinct algorithms.  The first algorithm compresses repeated
 * byte sequences, and the second algorithm takes the compressed
 * stream from the first algorithm and applies a probabilistic
 * compression method.
 *
 *)

  function reduce_L(x : Byte) : Byte;
  begin
    case factor of
      1 : reduce_L := x and $7f;
      2 : reduce_L := x and $3f;
      3 : reduce_L := x and $1f;
      4 : reduce_L := x and $0f;
    end;
  end;

  function reduce_F(x : Byte) : Byte;
  begin
    case factor of
      1 : if x = 127 then reduce_F := 2 else reduce_F := 3;
      2 : if x = 63 then reduce_F := 2 else reduce_F := 3;
      3 : if x = 31 then reduce_F := 2 else reduce_F := 3;
      4 : if x = 15 then reduce_F := 2 else reduce_F := 3;
    end;
  end;

  function reduce_D(x, y : Byte) : Word;
  begin
    case factor of
      1 : reduce_D := (((x shr 7) and $01) shl 8)+y+1;
      2 : reduce_D := (((x shr 6) and $03) shl 8)+y+1;
      3 : reduce_D := (((x shr 5) and $07) shl 8)+y+1;
      4 : reduce_D := (((x shr 4) and $0f) shl 8)+y+1;
    end;
  end;

  function reduce_B(x : Byte) : Word;
    {number of bits needed to encode the specified number}
  begin
    case x-1 of
      0..1 : reduce_B := 1;
      2..3 : reduce_B := 2;
      4..7 : reduce_B := 3;
      8..15 : reduce_B := 4;
      16..31 : reduce_B := 5;
      32..63 : reduce_B := 6;
      64..127 : reduce_B := 7;
    else reduce_B := 8;
    end;
  end;

  procedure Expand(C : Byte);
  const
    DLE            = 144;
  var
    op             : LongInt;
    op_x           : LongInt;
    i              : Integer;
    temp           : Integer;

  begin

    case ExState of
      0 : if C <> DLE then
            OutByte(C)
          else
            ExState := 1;

      1 : if C <> 0 then
            begin
              V := C;
              Len := reduce_L(V);
              ExState := reduce_F(Len);
            end
          else
            begin
              OutByte(DLE);
              ExState := 0;
            end;

      2 : begin
            Len := Len+C;
            ExState := 3;
          end;

      3 : begin
            op := outpos-reduce_D(V, C);
            if op >= SizeOf(outbuf)
            then op_x := op mod SizeOf(outbuf)
            else op_x := op;
            for i := 0 to Len+2 do
              begin
                if op < 0 then
                  OutByte(0)
                else begin
                  OutByte(outbuf[op_x]);
                  end;
                Inc(op);
                Inc(op_x);
                if op_x >= SizeOf(outbuf) then op_x := 0;
              end;

            ExState := 0;
          end;
    end;
  end;


  procedure LoadFollowers;
  var
    x              : Integer;
    i              : Integer;
    b              : Integer;
  begin
    for x := 255 downto 0 do
      begin
        ReadBits(6, b);
        followers[x][0] := Chr(b);

        for i := 1 to Length(followers[x]) do
          begin
            ReadBits(8, b);
            followers[x][i] := Chr(b);
          end;
      end;
  end;


  (* ----------------------------------------------------------- *)
  procedure unReduce;
    {expand probablisticly reduced data}

  var
    lchar          : Integer;
    lout           : Integer;
    i              : Integer;

  begin
    factor := cmethod-1;
    if (factor < 1) or (factor > 4) then
      begin
        skip_csize;
        Exit;
      end;

    ExState := 0;
    LoadFollowers;
    lchar := 0;

    while (not zipeof) and (outpos < cusize) do
      begin

        if followers[lchar] = '' then
          ReadBits(8, lout)
        else

          begin
            ReadBits(1, lout);
            if lout <> 0 then
              ReadBits(8, lout)
            else
              begin
                ReadBits(reduce_B(Length(followers[lchar])), i);
                lout := Ord(followers[lchar][i+1]);
              end;
          end;

        if zipeof then
          Exit;

        Expand(lout);
        lchar := lout;
      end;

  end;



(*
 * expand 'shrunk' members of a zipfile
 *
 *)

(*
 * UnShrinking
 * -----------
 *
 * Shrinking is a Dynamic Ziv-Lempel-Welch compression algorithm
 * with partial clearing.  The initial code size is 9 bits, and
 * the maximum code size is 13 bits.  Shrinking differs from
 * conventional Dynamic Ziv-lempel-Welch implementations in several
 * respects:
 *
 * 1)  The code size is controlled by the compressor, and is not
 *     automatically increased when codes larger than the current
 *     code size are created (but not necessarily used).  When
 *     the decompressor encounters the code sequence 256
 *     (decimal) followed by 1, it should increase the code size
 *     read from the input stream to the next bit size.  No
 *     blocking of the codes is performed, so the next code at
 *     the increased size should be read from the input stream
 *     immediately after where the previous code at the smaller
 *     bit size was read.  Again, the decompressor should not
 *     increase the code size used until the sequence 256,1 is
 *     encountered.
 *
 * 2)  When the table becomes full, total clearing is not
 *     performed.  Rather, when the compresser emits the code
 *     sequence 256,2 (decimal), the decompressor should clear
 *     all leaf nodes from the Ziv-Lempel tree, and continue to
 *     use the current code size.  The nodes that are cleared
 *     from the Ziv-Lempel tree are then re-used, with the lowest
 *     code value re-used first, and the highest code value
 *     re-used last.  The compressor can emit the sequence 256,2
 *     at any time.
 *
 *)

  procedure unShrink;

  const
    max_bits       = 13;
    init_bits      = 9;
    first_ent      = 257;
    clear          = 256;

  var
    cbits          : Integer;
    maxcode        : Integer;
    free_ent       : Integer;
    maxcodemax     : Integer;
    offset         : Integer;
    sizex          : Integer;
    finchar        : Integer;
    code           : Integer;
    oldcode        : Integer;
    incode         : Integer;


    (* ------------------------------------------------------------- *)
    procedure partial_clear;
    var
      pr             : Integer;
      cd             : Integer;

    begin
      {mark all nodes as potentially unused}
      for cd := first_ent to free_ent-1 do
        Word(prefix_of[cd]) := prefix_of[cd] or $8000;


      {unmark those that are used by other nodes}
      for cd := first_ent to free_ent-1 do
        begin
          pr := prefix_of[cd] and $7fff; {reference to another node?}
          if pr >= first_ent then {flag node as referenced}
            prefix_of[pr] := prefix_of[pr] and $7fff;
        end;


      {clear the ones that are still marked}
      for cd := first_ent to free_ent-1 do
        if (prefix_of[cd] and $8000) <> 0 then
          prefix_of[cd] := -1;


      {find first cleared node as next free_ent}
      free_ent := first_ent;
      while (free_ent < maxcodemax) and (prefix_of[free_ent] <> -1) do
        Inc(free_ent);
    end;


    (* ------------------------------------------------------------- *)
  begin
    (* decompress the file *)
    maxcodemax := 1 shl max_bits;
    cbits := init_bits;
    maxcode := (1 shl cbits)-1;
    free_ent := first_ent;
    offset := 0;
    sizex := 0;

    FillChar(prefix_of, SizeOf(prefix_of), $FF);
    for code := 255 downto 0 do
      begin
        prefix_of[code] := 0;
        suffix_of[code] := code;
      end;

    ReadBits(cbits, oldcode);
    if zipeof then
      Exit;
    finchar := oldcode;

    OutByte(finchar);

    stackp := 0;

    while (not zipeof) do
      begin
        ReadBits(cbits, code);
        if zipeof then
          Exit;

        while (code = clear) do
          begin
            ReadBits(cbits, code);

            case code of
              1 : begin
                    Inc(cbits);
                    if cbits = max_bits then
                      maxcode := maxcodemax
                    else
                      maxcode := (1 shl cbits)-1;
                  end;

              2 : partial_clear;
            end;

            ReadBits(cbits, code);
            if zipeof then
              Exit;
          end;


        {special case for KwKwK string}
        incode := code;
        if prefix_of[code] = -1 then
          begin
            stack[stackp] := finchar;
            Inc(stackp);
            code := oldcode;
          end;


        {generate output characters in reverse order}
        while (code >= first_ent) do
          begin
            stack[stackp] := suffix_of[code];
            Inc(stackp);
            code := prefix_of[code];
          end;

        finchar := suffix_of[code];
        stack[stackp] := finchar;
        Inc(stackp);


        {and put them out in forward order}
        while (stackp > 0) do
          begin
            Dec(stackp);
            OutByte(stack[stackp]);
          end;


        {generate new entry}
        code := free_ent;
        if code < maxcodemax then
          begin
            prefix_of[code] := oldcode;
            suffix_of[code] := finchar;
            while (free_ent < maxcodemax) and (prefix_of[free_ent] <> -1) do
              Inc(free_ent);
          end;


        {remember previous code}
        oldcode := incode;
      end;

  end;



  (* ------------------------------------------------------------- *)
(*
 * Imploding
 * ---------
 *
 * The Imploding algorithm is actually a combination of two distinct
 * algorithms.  The first algorithm compresses repeated byte sequences
 * using a sliding dictionary.  The second algorithm is used to compress
 * the encoding of the sliding dictionary ouput, using multiple
 * Shannon-Fano trees.
 *
 *)

const
  maxSF          = 256;

type
  sf_entry       = record
                     code           : Word;
                     Value          : Byte;
                     BitLength      : Byte;
                   end;

  sf_tree        = record         {a shannon-fano tree}
                     entry          : array[0..maxSF] of sf_entry;
                     entries        : Integer;
                     MaxLength      : Integer;
                   end;

  sf_treep       = ^sf_tree;

var
  lit_tree       : sf_tree;
  length_tree    : sf_tree;
  distance_tree  : sf_tree;
  lit_tree_present : Boolean;
  eightK_dictionary : Boolean;
  minimum_match_length : Integer;
  dict_bits      : Integer;


  {$I UNZSORT.INC}

  (* ----------------------------------------------------------- *)
  procedure ReadLengths(var tree : sf_tree);
  var
    treeBytes      : Integer;
    i, j, k        : Integer;
    num, Len       : Integer;

  begin
    {get number of bytes in compressed tree}
    ReadBits(8, treeBytes);
    Inc(treeBytes);
    i := 0;

    begin
      tree.MaxLength := 0;

      {High 4 bits: Number of values at this bit length + 1. (1 - 16)
       Low  4 bits: Bit Length needed to represent value + 1. (1 - 16)}
      for j := 1 to treeBytes do
        begin
          ReadBits(4, Len); Inc(Len);
          ReadBits(4, num); Inc(num);

          for k := i to i+num-1 do
            begin
              if Len > tree.MaxLength then
                tree.MaxLength := Len;
              tree.entry[k].BitLength := Len;
              tree.entry[k].Value := k;
            end;
          Inc(i, num);

          Dec(treeBytes);
        end;
    end;
  end;


  (* ----------------------------------------------------------- *)
  procedure GenerateTrees(var tree : sf_tree);
    {Generate the Shannon-Fano trees}
  var
    code           : Word;
    CodeIncrement  : Integer;
    LastBitLength  : Integer;
    i              : Integer;

  begin
    code := 0;
    CodeIncrement := 0;
    LastBitLength := 0;

    i := tree.entries-1;          {either 255 or 63}
    while i >= 0 do
      begin
        Inc(code, CodeIncrement);
        if tree.entry[i].BitLength <> LastBitLength then
          begin
            LastBitLength := tree.entry[i].BitLength;
            CodeIncrement := 1 shl (16-LastBitLength);
          end;

        tree.entry[i].code := code;
        Dec(i);
      end;
  end;


  (* ----------------------------------------------------------- *)
  procedure ReverseBits(var tree : sf_tree);
   {Reverse the order of all the bits in the above ShannonCode[]
    vector, so that the most significant bit becomes the least
    significant bit. For example, the value 0x1234 (hex) would become
    0x2C48 (hex).}
  var
    i              : Integer;
    V              : Word;
    o              : Word;

  begin
    for i := 0 to tree.entries-1 do
      begin
        {get original code}
        o := tree.entry[i].code;
        V := 0;
        {reverse each bit}
        if (o and $0001) <> 0 then V := $8000;
        if (o and $0002) <> 0 then V := V or $4000;
        if (o and $0004) <> 0 then V := V or $2000;
        if (o and $0008) <> 0 then V := V or $1000;
        if (o and $0010) <> 0 then V := V or $0800;
        if (o and $0020) <> 0 then V := V or $0400;
        if (o and $0040) <> 0 then V := V or $0200;
        if (o and $0080) <> 0 then V := V or $0100;
        if (o and $0100) <> 0 then V := V or $0080;
        if (o and $0200) <> 0 then V := V or $0040;
        if (o and $0400) <> 0 then V := V or $0020;
        if (o and $0800) <> 0 then V := V or $0010;
        if (o and $1000) <> 0 then V := V or $0008;
        if (o and $2000) <> 0 then V := V or $0004;
        if (o and $4000) <> 0 then V := V or $0002;
        if (o and $8000) <> 0 then V := V or $0001;

        {store reversed bits}
        tree.entry[i].code := V;
      end;
  end;


  (* ----------------------------------------------------------- *)
  procedure LoadTree(var tree       : sf_tree;
                     treesize       : Integer);
    {allocate and load a shannon-fano tree from the compressed file}
  begin
    tree.entries := treesize;
    ReadLengths(tree);
    SortLengths(tree);
    GenerateTrees(tree);
    ReverseBits(tree);
  end;


  (* ----------------------------------------------------------- *)
  procedure LoadTrees;
  begin
    eightK_dictionary := (cflags and $02) <> 0; {bit 1}
    lit_tree_present := (cflags and $04) <> 0; {bit 2}

    if eightK_dictionary then
      dict_bits := 7
    else
      dict_bits := 6;

    if lit_tree_present then
      begin
        minimum_match_length := 3;
        LoadTree(lit_tree, 256);
      end
    else
      minimum_match_length := 2;

    LoadTree(length_tree, 64);
    LoadTree(distance_tree, 64);
  end;


  (* ----------------------------------------------------------- *)
  procedure ReadTree(var tree       : sf_tree;
                     var dest       : Integer);
    {read next byte using a shannon-fano tree}
  var
    bits           : Integer;
    cv             : Word;
    b              : Integer;
    cur            : Integer;

  begin
    bits := 0;
    cv := 0;
    cur := 0;
    dest := -1;                   {in case of error}

    while True do
      begin
        ReadBits(1, b);
        cv := cv or (b shl bits);
        Inc(bits);

      (* this is a very poor way of decoding shannon-fano.  two quicker
      methods come to mind:
         a) arrange the tree as a huffman-style binary tree with
            a "leaf" indicator at each node,
      and
         b) take advantage of the fact that s-f codes are at most 8
            bits long and alias unused codes for all bits following
            the "leaf" bit.
      *)

        while tree.entry[cur].BitLength < bits do
          begin
            Inc(cur);
            if cur >= tree.entries then
              Exit;
          end;

        while tree.entry[cur].BitLength = bits do
          begin
            if tree.entry[cur].code = cv then
              begin
                dest := tree.entry[cur].Value;
                Exit;
              end;

            Inc(cur);
            if cur >= tree.entries then
              Exit;
          end;
      end;
  end;


  (* ----------------------------------------------------------- *)
  procedure unImplode;
    {expand imploded data}

  var
    lout           : Integer;
    op             : LongInt;
    op_x           : LongInt;
    Length         : Integer;
    Distance       : Integer;
    i              : Integer;
    temp           : Integer;

  begin
    LoadTrees;

    while (not zipeof) and (outpos < cusize) do
      begin
        ReadBits(1, lout);

        if lout <> 0 then         {encoded data is literal data}
          begin
            if lit_tree_present then
              ReadTree(lit_tree, lout) {use Literal Shannon-Fano tree}
            else
              ReadBits(8, lout);

            OutByte(lout);
          end
        else

          begin                   {encoded data is sliding dictionary match}
            ReadBits(dict_bits, lout);
            Distance := lout;

            ReadTree(distance_tree, lout);
            Distance := Distance or (lout shl dict_bits);
         {using the Distance Shannon-Fano tree, read and decode the
            upper 6 bits of the Distance value}

            ReadTree(length_tree, Length);
            {using the Length Shannon-Fano tree, read and decode the Length value}

            Inc(Length, minimum_match_length);
            if Length = (63+minimum_match_length) then
              begin
                ReadBits(8, lout);
                Inc(Length, lout);
              end;

         {move backwards Distance+1 bytes in the output stream, and copy
          Length characters from this position to the output stream.
          (if this position is before the start of the output stream,
          then assume that all the data before the start of the output
          stream is filled with zeros)}

            op := outpos-Distance-1;
            if op >= SizeOf(outbuf)
            then op_x := op mod SizeOf(outbuf)
            else op_x := op;
            for i := 1 to Length do
              begin
                if op < 0 then
                  OutByte(0)
                else
                  OutByte(outbuf[op_x]);
                Inc(op);
                Inc(op_x);
                if op_x >= SizeOf(outbuf) then op_x := 0;
              end;
          end;
      end;
  end;



(*
 * This procedure displays the text contents of a specified archive
 * file.  The filename must be fully specified and verified.
 *
 *)


  (* ---------------------------------------------------------- *)
  procedure extract_member;
  var
    b              : Byte;

  begin
    pcbits := 0;
    pc := 0;
    incnt := 0;
    inpos := 1+SizeOf(inbuf);
    outpos := 0;
    outcnt := 0;
    zipeof := False;
    Crc32Val := -1;

    outfd := dos_create(filename);
    if outfd = dos_error then
      begin
        WriteLn('Can''t create output: ', filename);
        Halt;
      end;

    case cmethod of
      0 :                         {stored}
        begin
          Write(' Extract: ', filename, ' ...');
          ReadByte(b);
          while (not zipeof) do
            begin
              OutByte(b);
              ReadByte(b);
            end;
        end;

      1 : begin
            Write('UnShrink: ', filename, ' ...');
            unShrink;
          end;

      2..5 : begin
               Write('  Expand: ', filename, ' ...');
               unReduce;
             end;

      6 : begin
            Write(' Explode: ', filename, ' ...');
            unImplode;
          end;

    else Write('Unknown compression method.');
    end;

    if outcnt > 0
    then begin
         Crc32Val := UpdateCRC32(Crc32Val,outbuf,outcnt);
         dos_write(outfd, outbuf, outcnt);
         end;

    dos_file_times(outfd, time_set, ctime, cdate);
    dos_close(outfd);
    Crc32Val := not Crc32Val;
    if Crc32Val <> InCrc
    then begin
      WriteLn('WARNING - preceeding fails CRC check.');
      WriteLn('Stored CRC=', itohs(InCrc));
      WriteLn('Calculated CRC=', itohs(Crc32Val));
    end;

    WriteLn('  done.');
  end;


  (* ---------------------------------------------------------- *)
  procedure process_local_file_header;
  var
    n              : Word;
    rec            : local_file_header;

  begin
    n := dos_read(zipfd, rec, SizeOf(rec));
    get_string(rec.filename_length, filename);
    get_string(rec.extra_field_length, extra);
    csize := rec.compressed_size;
    cusize := rec.uncompressed_size;
    cmethod := rec.compression_method;
    cflags := rec.general_purpose_bit_flag;
    ctime := rec.last_mod_file_time;
    cdate := rec.last_mod_file_date;
    InCrc := rec.crc32;
    extract_member;
  end;


  (* ---------------------------------------------------------- *)
  procedure process_central_file_header;
  var
    n              : Word;
    rec            : central_directory_file_header;
    filename       : String;
    extra          : String;
    comment        : String;

  begin
    n := dos_read(zipfd, rec, SizeOf(rec));
    get_string(rec.filename_length, filename);
    get_string(rec.extra_field_length, extra);
    get_string(rec.file_comment_length, comment);
  end;


  (* ---------------------------------------------------------- *)
  procedure process_end_central_dir;
  var
    n              : Word;
    rec            : end_central_dir_record;
    comment        : String;

  begin
    n := dos_read(zipfd, rec, SizeOf(rec));
    get_string(rec.zipfile_comment_length, comment);
  end;


  (* ---------------------------------------------------------- *)
  procedure process_headers;
  var
    sig            : LongInt;

  begin
    dos_lseek(zipfd, 0, seek_start);

    while True do
      begin
        if dos_read(zipfd, sig, SizeOf(sig)) <> SizeOf(sig) then
          Exit
        else

          if sig = local_file_header_signature then
            process_local_file_header
          else

            if sig = central_file_header_signature then
              process_central_file_header
            else

              if sig = end_central_dir_signature then
                begin
                  process_end_central_dir;
                  Exit;
                end

              else
                begin
                  WriteLn('Invalid Zipfile Header');
                  Exit;
                end;
      end;

  end;


  (* ---------------------------------------------------------- *)
  procedure extract_zipfile;
  begin
    zipfd := dos_open(zipfn, open_read);
    if zipfd = dos_error then
      Exit;

    process_headers;

    dos_close(zipfd);
  end;


(*
 * main program
 *
 *)

begin
  if ParamCount <> 1 then
    begin
      WriteLn;
      WriteLn(version);
      WriteLn('Courtesy of:  S.H.Smith  and  The Tool Shop BBS,  [phone].');
      WriteLn;
      WriteLn('You may copy and distribute this program freely, provided that:');
      WriteLn('    1)   No fee is charged for such copying and distribution, and');
      WriteLn('    2)   It is distributed ONLY in its original, unmodified state.');
      WriteLn('If you wish to distribute a modified version of this program, you MUST');
      WriteLn('include the source code.');
      WriteLn;
      WriteLn('If you modify this program, I would appreciate a copy of the  new source');
      WriteLn('code.   I am holding the copyright on the source code, so please don''t');
      WriteLn('delete my name from the program files or from the documentation.');
      WriteLn('IN NO EVENT WILL I BE LIABLE TO YOU FOR ANY DAMAGES, INCLUDING ANY LOST');
      WriteLn('PROFITS, LOST SAVINGS OR OTHER INCIDENTAL OR CONSEQUENTIAL DAMAGES');
      WriteLn('ARISING OUT OF YOUR USE OR INABILITY TO USE THE PROGRAM, OR FOR ANY');
      WriteLn('CLAIM BY ANY OTHER PARTY.');
      WriteLn;
      WriteLn('Usage:  UnZip FILE[.zip]');
      Halt;
    end;

  zipfn := ParamStr(1);
  if Pos('.', zipfn) = 0 then
    zipfn := zipfn+'.ZIP';

  extract_zipfile;
end.